ADA Programming Guide/ADA Programming Guide.iso/ada_gnu/adainc/a-sequio.adb

Text File | 1996-01-30 | 16.1 KB | 500 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                    A D A . S E Q U E N T I A L _ I O                     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.4 $                              --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Storage_IO;
with Interfaces.C;          use Interfaces.C;
with Interfaces.C.Strings;  use Interfaces.C.Strings;
with System.File_Aux;       use System.File_Aux;

package body Ada.Sequential_IO is

   package Stor_IO is new Ada.Storage_IO (Element_Type => Element_Type);

   type Pstring is access String;

   type File_Control_Block is record
      Name       : chars_ptr := Null_Ptr;
      Mode       : File_Mode;
      Form       : Pstring;
      Descriptor : C_File_Ptr;
      Byte_Size  : C_Long_Int;
      Byte_Index : C_Long_Int;
   end record;

   type Open_Type is (Create, Open);

   type C_Mode_Type is array (Open_Type, File_Mode) of chars_ptr;

   C_Mode : C_Mode_Type := (others => (others => Null_Ptr));

   Buffer : Stor_IO.Buffer_Type;

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Confirm_File_Is_Open (File : in File_Type);
   pragma Inline (Confirm_File_Is_Open);
   --  Checks to make sure the given file is open.
   --  If not, it raises Status_Error.

   procedure Confirm_File_Is_Closed (File : in File_Type);
   pragma Inline (Confirm_File_Is_Closed);
   --  Checks to make sure the given file is closed.
   --  If not, it raises Status_Error.

   function Current_Size_Of (File : in File_Type) return C_Long_Int;
   --  Returns the current size in bytes of the external file that is
   --  associated with the given file.  The given file must be open.

   function New_Temp_File_Name return chars_ptr;
   --  Returns a name that is a valid file name and that is not the same as
   --  the name of an existing external file.

   function File_Exists (Name : in String) return Boolean;
   --  Returns True if an external file of the given name exists.
   --  Otherwise, it returns False.

   -----------
   -- Close --
   -----------

   procedure Close  (File : in out File_Type) is
   begin
      Confirm_File_Is_Open (File);

      if C_Fclose (File.Descriptor) /= 0 then
         raise Device_Error;
      end if;

      File := null;
   end Close;

   --------------------------
   -- Confirm_File_Is_Open --
   --------------------------

   procedure Confirm_File_Is_Open (File : in File_Type) is
   begin
      if not Is_Open (File) then
         raise Status_Error;
      end if;
   end Confirm_File_Is_Open;

   ----------------------------
   -- Confirm_File_Is_Closed --
   ----------------------------

   procedure Confirm_File_Is_Closed (File : in File_Type) is
   begin
      if Is_Open (File) then
         raise Status_Error;
      end if;
   end Confirm_File_Is_Closed;

   ------------
   -- Create --
   ------------

   procedure Create
     (File : in out File_Type;
      Mode : in File_Mode := Out_File;
      Name : in String := "";
      Form : in String := "")
   is
   begin
      Confirm_File_Is_Closed (File);
      File := new File_Control_Block;

      --  A null string for Name specifies creation of a temporary file.

      if Name'Length = 0 then
         File.Name := New_Temp_File_Name;
      else
         File.Name := New_String (Name);
      end if;

      File.Descriptor := C_Fopen (Filename => File.Name,
                                  Mode     => C_Mode (Create, Mode));

      --  If the C fopen call fails, it returns a null pointer.

      if C_Void_Ptr (File.Descriptor) = C_Null then
         raise Name_Error;
      end if;

      File.Mode := Mode;
      File.Form := new String'(Form);

      --  The size of the external file is required in order to avoid
      --  lookahead.  In C, the end-of-file indicator is not considered to
      --  be true until after an attempt is made to read past the end of the
      --  external file.  In Ada, the End_Of_File function returns True if no
      --  more elements can be read (i.e. when reading elements, End_Of_File
      --  becomes True before a failed read caused by end-of-file).  In
      --  Sequential_IO, it is sufficient to determine the size of the
      --  external file once at the time of the opening of the file.  The
      --  End_Of_File function only operates on a file of mode In_File, and
      --  such a file will not change in size.

      File.Byte_Size  := Current_Size_Of (File);
      File.Byte_Index := 0;
   end Create;

   ---------------------
   -- Current_Size_Of --
   ---------------------

   function Current_Size_Of (File : in File_Type) return C_Long_Int is
      Current_Byte_Index : C_Long_Int;
      Current_Byte_Size  : C_Long_Int;

   begin
      Current_Byte_Index := C_Ftell (File.Descriptor);

      if C_Fseek (Stream => File.Descriptor,
                  Offset => 0,
                  Whence => C_Seek_End) /= 0 then
         raise Device_Error;
      end if;

      Current_Byte_Size := C_Ftell (File.Descriptor);

      if C_Fseek (Stream => File.Descriptor,
                  Offset => Current_Byte_Index,
                  Whence => C_Seek_Set) /= 0 then
         raise Device_Error;
      end if;

      return Current_Byte_Size;
   end Current_Size_Of;

   ------------
   -- Delete --
   ------------

   procedure Delete (File : in out File_Type) is
      File_Name_To_Delete : chars_ptr;

   begin
      Confirm_File_Is_Open (File);

      --  The file should be closed before calling the C remove function.
      --  If the file is open, the behavior of the remove function is
      --  implementation-defined.  Closing the file, however, means we
      --  lose the info in the file control block, so we have to save the
      --  file name temporarily in order to have it for use with the remove
      --  function.

      File_Name_To_Delete := File.Name;
      Close (File);

      if C_Remove (File_Name_To_Delete) /= 0 then
         raise Use_Error;
      end if;
   end Delete;

   -----------------
   -- End_Of_File --
   -----------------

   function End_Of_File (File : in File_Type) return Boolean is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode /= In_File then
         raise Mode_Error;
      end if;

      return File.Byte_Index >= File.Byte_Size;
   end End_Of_File;

   -----------------
   -- File_Exists --
   -----------------

   function File_Exists (Name : in String) return Boolean is
      File_Descriptor : C_File_Ptr;
      C_Name          : chars_ptr;

   begin
      C_Name := New_String (Name);
      File_Descriptor := C_Fopen (Filename => C_Name,
                                  Mode     => C_Mode (Open, In_File));

      if C_Void_Ptr (File_Descriptor) = C_Null then
         return False;
      end if;

      if C_Fclose (File_Descriptor) /= 0 then
         raise Device_Error;
      end if;

      return True;
   end File_Exists;

   ----------
   -- Form --
   ----------

   function Form (File : in File_Type) return String is
   begin
      Confirm_File_Is_Open (File);
      return File.Form.all;
   end Form;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (File : in File_Type) return Boolean is
   begin
      return File /= null;
   end Is_Open;

   ----------
   -- Mode --
   ----------

   function Mode (File : in File_Type) return File_Mode is
   begin
      Confirm_File_Is_Open (File);
      return File.Mode;
   end Mode;

   ----------
   -- Name --
   ----------

   function Name (File : in File_Type) return String is
   begin
      Confirm_File_Is_Open (File);
      return Value (File.Name);
   end Name;

   ------------------------
   -- New_Temp_File_Name --
   ------------------------

   function New_Temp_File_Name return chars_ptr is
      Temp_File_Name   : String := "ADATMPXX";
      C_Temp_File_Name : chars_ptr;

   begin
      C_Temp_File_Name := New_String (Temp_File_Name);
      C_Temp_File_Name := C_Mktemp (C_Temp_File_Name);
      return C_Temp_File_Name;
   end New_Temp_File_Name;

   ----------
   -- Open --
   ----------

   procedure Open
     (File : in out File_Type;
      Mode : in File_Mode;
      Name : in String;
      Form : in String := "")
   is
   begin
      Confirm_File_Is_Closed (File);

      --  The language standard specifies that Name_Error must be raised if
      --  no external file with the given name exists.  This should occur
      --  regardless of the given mode.  The mode argument to the C fopen
      --  function does not have sufficient flexibility to handle this
      --  behavior with one call to fopen.  In particular, opening a file with
      --  mode Out_File should fail if the external file does not exist, but
      --  should open and truncate the external file if it exists.  The C
      --  fopen funcation has no direct equivalent of this, as an fopen with
      --  write mode succeeds whether the file exists or not.  In order to
      --  get the desired behavior in Ada, we need to do a separate check for
      --  file existence prior to the C fopen call to open the file.

      if not File_Exists (Name) then
         raise Name_Error;
      end if;

      File := new File_Control_Block;

      File.Name := New_String (Name);
      File.Descriptor := C_Fopen (Filename => File.Name,
                                  Mode     => C_Mode (Open, Mode));

      --  If the C fopen call fails, it returns a null pointer.

      if C_Void_Ptr (File.Descriptor) = C_Null then
         raise Name_Error;
      end if;

      File.Mode := Mode;
      File.Form := new String'(Form);

      --  The size of the external file is required in order to avoid
      --  lookahead.  In C, the end-of-file indicator is not considered to
      --  be true until after an attempt is made to read past the end of the
      --  external file.  In Ada, the End_Of_File function returns True if no
      --  more elements can be read (i.e. when reading elements, End_Of_File
      --  becomes True before a failed read caused by end-of-file).  In
      --  Sequential_IO, it is sufficient to determine the size of the
      --  external file once at the time of the opening of the file.  The
      --  End_Of_File function only operates on a file of mode In_File, and
      --  such a file will not change in size.

      File.Byte_Size  := Current_Size_Of (File);
      File.Byte_Index := 0;
   end Open;

   ----------
   -- Read --
   ----------

   procedure Read (File : in File_Type; Item : out Element_Type) is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode /= In_File then
         raise Mode_Error;
      end if;

      if End_Of_File (File) then
         raise End_Error;
      end if;

      --  The C fread function returns the number of elements successfully
      --  read.  Since we only read one element at a time and we have already
      --  checked for end of file, if the number of elements successfully read
      --  does not equal the number of elements requested, it is considered to
      --  be a Device_Error.

      if C_Fread (Ptr    => C_Void_Ptr (Buffer'Address),
                  Size   => C_Size_T (Buffer'Length),
                  Nmemb  => 1,
                  Stream => File.Descriptor) /= 1
      then
         raise Device_Error;
      end if;

      --  Advance the byte index so we can check for end of file.

      File.Byte_Index := File.Byte_Index + Buffer'Length;

      Stor_IO.Read (Buffer, Item);
   end Read;

   -----------
   -- Reset --
   -----------

   procedure Reset  (File : in out File_Type; Mode : in File_Mode) is
      Old_File : File_Type := File;

   begin
      Confirm_File_Is_Open (File);
      Close (File);
      Open (File, Mode, Value (Old_File.Name), Old_File.Form.all);
   end Reset;

   procedure Reset  (File : in out File_Type) is
   begin
      Confirm_File_Is_Open (File);
      Reset (File, File.Mode);
   end Reset;

   -----------
   -- Write --
   -----------

   procedure Write (File : in File_Type; Item : in Element_Type) is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode = In_File then
         raise Mode_Error;
      end if;

      Stor_IO.Write (Buffer, Item);

      --  The C fwrite function returns the number of elements successfully
      --  written, which will less than the number of elements requested only
      --  if a write error is encountered.  Such a situation is considered to
      --  be a Device_Error.

      if C_Fwrite (Ptr    => C_Void_Ptr (Buffer'Address),
                   Size   => C_Size_T (Buffer'Length),
                   Nmemb  => 1,
                   Stream => File.Descriptor) /= 1
      then
         raise Device_Error;
      end if;
   end Write;

begin
   -------------------------
   -- Package Elaboration --
   -----------------
   --  The following possible modes for the C fopen function are given here
   --  for reference:
   --
   --  r   open text file for reading
   --  w   truncate to zero length or create text file for writing
   --  a   append; open or create text file for writing at end-of-file
   --  rb  open binary file for reading
   --  wb  truncate to zero length or create binary file for writing
   --  ab  append; open or create binary file for writing at end-of-file
   --  r+  open text file for update (reading and writing)
   --  w+  truncate to zero length or create text file for update
   --  a+  append; open or create text file for update, writing at end-of-file
   --  rb+ open binary file for update (reading and writing)
   --  wb+ truncate to zero length or create binary file for update
   --  ab+ append; open or create binary file for update, writing at
   --      end-of-file
   --
   --  Notes:
   --
   --  (1) Opening a file with read mode fails if the file does not exist or
   --  cannot be read.
   --
   --  (2) Opening a file with append mode causes all subsequent writes to the
   --  file to be forced to the then current end-of-file, regardless of
   --  intervening calls to the fseek function.
   --
   --  (3) When a file is opened with update mode, both input and output may be
   --  performed on the associated stream.  However, output may not be directly
   --  followed by input without an intervening call to the fflush function or
   --  to a file positioning function (fseek, fsetpos, or rewind), and input
   --  may not be directly followed by output without an intervening call to a
   --  file positioning function, unless the input operation encounters
   --  end-of-file.

   C_Mode (Create, In_File)     := New_String ("wb");
   C_Mode (Create, Out_File)    := New_String ("wb");
   C_Mode (Create, Append_File) := New_String ("wb");

   C_Mode (Open,   In_File)     := New_String ("rb");
   C_Mode (Open,   Out_File)    := New_String ("wb");
   C_Mode (Open,   Append_File) := New_String ("ab");
end Ada.Sequential_IO;